Collection of Tools & Utilities/Collection of Tools and Utilities.iso/pascal/tptc17sc.zip/TPCSTMT.INC

Text File | 1988-03-25 | 24KB | 1,136 lines

(*
 * TPTC - Turbo Pascal to C translator
 *
 * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
 *
 *)

(********************************************************************)
(*
 * control statement processors
 *    for, while, repeat, with, idents
 *
 * all expect tok to be keyword
 * all exit at end of statement with ltok as ; or end
 *
 *)

procedure pfor;
var
   up:       boolean;
   id:       string80;
   low,high: string80;

begin
   if debug_parse then write(' <for>');

   nospace := true;
   puts('for (');
   gettok;   {consume the FOR}

   id := plvalue;
   gettok;   {consume the :=}

   low := pexpr;

   if tok = 'TO' then
      up := true
   else

   if tok = 'DOWNTO' then
      up := false;

   gettok;
   high := pexpr;

   if up then
      puts(id+' = '+low+'; '+id+' <= '+high+'; '+id+'++) ')
   else
      puts(id+' = '+low+'; '+id+' >= '+high+'; '+id+'--) ');

   nospace := false;
   gettok;   {consume the DO}
   pstatement;
end;


(********************************************************************)
procedure pwhile;
begin
   if debug_parse then write(' <while>');
   gettok;   {consume the WHILE}

   nospace := true;
   puts('while ('+pexpr+') ');
   nospace := false;

   gettok;   {consume the DO}
   pstatement;
end;


(********************************************************************)
procedure pwith;
var
   prefix: string;
   levels: integer;

begin
   if debug_parse then write(' <with>');
   gettok;   {consume the WITH}

   {warning('WITH not translated');}
   levels := 0;
   puts('{ ');
   nospace := true;

   repeat
      if tok[1] = ',' then
      begin
         gettok;
         newline;
         puts('  ');
      end;

      prefix := plvalue;
      make_pointer(prefix);

      inc(levels);
      inc(withlevel);
      puts('void *with'+itoa(withlevel)+' = '+prefix+'; ');

   until tok[1] <> ',';

   nospace := false;
   gettok;   {consume the DO}

   if tok[1] <> '{' then
      pstatement
   else

   begin
      gettok;                 {consume the open brace}

      while (tok[1] <> '}') and not recovery do
      begin
         pstatement;          {process the statement}

         if tok[1] = ';' then
         begin
            puttok;
            gettok;           {get first token of next statement}
         end;
      end;

      gettok;                 {consume the close brace}
   end;

   puts('   } ');
   newline;

   if tok[1] = ';' then
      gettok;

   dec(withlevel,levels);
end;


(********************************************************************)
procedure prepeat;
begin
   if debug_parse then write(' <repeat>');
   puts('do { ');
   gettok;

   while (tok <> 'UNTIL') and not recovery do
   begin
      pstatement;

      if tok[1] = ';' then
      begin
         puttok;
         gettok;
      end;
   end;

   gettok;
   nospace := true;
   puts('}  while (!('+ pexpr+ '))');
   nospace := false;
end;


(********************************************************************)
procedure pcase;
var
   ex:  string80;
   ex2: string80;
   i:   integer;
   c:   char;

begin
   if debug_parse then write(' <case>');
   gettok;
   ex := pexpr;
   puts('switch ('+ex+') {');

   gettok;   {consume the OF}

   while (tok[1] <> '}') and (tok <> 'ELSE') and not recovery do
   begin

      repeat
         if tok[1] = ',' then
            gettok;

         if tok = '..' then
         begin
            gettok;
            ex2 := pexpr;

            if (ex2[1] = '''') or (ex2[1] = '"') then
               for c := succ(ex[2]) to ex2[2] do
               begin
                  newline;
                  puts('case '''+c+''':   ');
               end
            else

            if atoi(ex2) - atoi(ex) > 128 then
            begin
               ltok := ex+'..'+ex2;
               warning('Gigantic case range');
            end
            else

            for i := succ(atoi(ex)) to atoi(ex2) do
            begin
               newline;
               write(ofd[unitlevel],'case ',i,':   ');
            end;
         end
         else

         begin
            ex := pexpr;
            newline;
            puts('case '+ex+':   ');
         end;

      until (tok[1] = ':') or recovery;
      gettok;

      if (tok[1] <> '}') and (tok <> 'ELSE') then
         pstatement;
      puts('break; ');
      newline;

      if tok[1] = ';' then
         gettok;
   end;

   if tok = 'ELSE' then
   begin
      newline;
      puts('default: ');
      gettok;   {consume the else}

      while (tok[1] <> '}') and not recovery do
      begin
         if (tok[1] <> '}') and (tok <> 'ELSE') then
            pstatement;
         if tok[1] = ';' then
            gettok;
      end;
   end;

   puttok;
   gettok;

   if tok[1] = ';' then
      gettok;
end;


(********************************************************************)
procedure pif;
var
   pspace: integer;
begin
   if debug_parse then write(' <if>');
   gettok;   {consume the IF}

   pspace := length(spaces);
   nospace := true;
   puts('if ('+ pexpr+ ') ');
   nospace := false;

   gettok;   {consume the THEN}

   if (tok[1] <> '}') and (tok <> 'ELSE') then
      pstatement;

   if tok = 'ELSE' then
   begin
      spaces := copy(spaces,1,pspace);
      if not linestart then
         newline;
      puts('else ');

      gettok;
      if tok[1] <> '}' then
         pstatement;
   end;

end;


(********************************************************************)
procedure pexit;
begin
   if debug_parse then write(' <exit>');
   puts('return;');

   gettok;
   if tok[1] = ';' then
      gettok;
end;


(********************************************************************)
procedure pgoto;
var
   ex:  anystring;

begin
   gettok;                      {consume the goto}

   if toktype = number then
      ltok := 'label_' + ltok;  {modify numeric labels}

   puts('goto '+ltok+';');

   gettok;                      {consume the label}

   if tok[1] = ';' then
      gettok;
end;


(********************************************************************)
procedure phalt;
var
   ex: anystring;

begin
   if debug_parse then write(' <halt>');
   gettok;

   if tok[1] = '(' then
   begin
      gettok;
      ex := pexpr;
      gettok;
   end
   else
      ex := '0';     {default exit expression}

   puts('exit('+ex+');');

   if tok[1] = ';' then
      gettok;
end;


(********************************************************************)
procedure pread;
var
   ctl:  string;
   func: anystring;
   ex:   paramlist;
   p:    string;
   ln:   boolean;
   ty:   string[2];
   i:    integer;

begin
   if debug_parse then write(' <read>');

   nospace := true;   {don't copy source whitespace to output during
                       this processing.  this prevents spaces from
                       getting moved around}

   ln := tok = 'READLN';
   nospace := true;
   func := 'scanv(';

   gettok;   {consume the read}

   if tok[1] = '(' then
   begin
      gettok;

      if ltok[1] = '[' then   {check for MT+ [addr(name)], form}
      begin
         gettok;   {consume the '[' }

         if tok[1] = ']' then
            func := 'scanf('
         else

         begin
            gettok;   {consume the ADDR}
            gettok;   {consume the '(' }
            func := 'fiscanf(' + usetok + ',';
            gettok;   {consume the ')'}
         end;

         gettok;   {consume the ']'}
         if tok[1] = ',' then
            gettok;
      end;

      ctl := '';
      ex.n := 0;

      while (tok[1] <> ')') and not recovery do
      begin
         p := pexpr;
         ty := exprtype;

         {convert to fprintf if first param is a file variable}
         if (ex.n = 0) and (ty = '@') then
            func := 'fs